home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_gimp.idb / usr / freeware / share / gimp / scripts / image-structure.scm.z / image-structure.scm
Encoding:
GIMP Script-Fu Script  |  1999-07-21  |  6.8 KB  |  155 lines
  1. ;;; image-structure.scm -*-scheme-*-
  2. ;;; Time-stamp: <1998/03/28 02:46:26 narazaki@InetQ.or.jp>
  3. ;;; Author: Shuji Narazaki <narazaki@InetQ.or.jp>
  4. ;;; Version 0.7
  5. ;;; Code:
  6.  
  7. (if (not (symbol-bound? 'script-fu-show-image-structure-new-image?
  8.             (the-environment)))
  9.     (define script-fu-show-image-structure-new-image? TRUE))
  10. (if (not (symbol-bound? 'script-fu-show-image-structure-space 
  11.             (the-environment)))
  12.     (define script-fu-show-image-structure-space 50))
  13. (if (not (symbol-bound? 'script-fu-show-image-structure-shear-length
  14.             (the-environment)))
  15.     (define script-fu-show-image-structure-shear-length 50))
  16. (if (not (symbol-bound? 'script-fu-show-image-structure-border
  17.             (the-environment)))
  18.     (define script-fu-show-image-structure-border 10))
  19. (if (not (symbol-bound? 'script-fu-show-image-structure-apply-layer-mask?
  20.             (the-environment)))
  21.     (define script-fu-show-image-structure-apply-layer-mask? TRUE))
  22. (if (not (symbol-bound? 'script-fu-show-image-structure-with-layer-name?
  23.             (the-environment)))
  24.     (define script-fu-show-image-structure-with-layer-name? TRUE))
  25. (if (not (symbol-bound? 'script-fu-show-image-structure-with-pad?
  26.             (the-environment)))
  27.     (define script-fu-show-image-structure-with-pad? TRUE))
  28. (if (not (symbol-bound? 'script-fu-show-image-structure-padding-color
  29.             (the-environment)))
  30.     (define script-fu-show-image-structure-padding-color '(255 255 255)))
  31. (if (not (symbol-bound? 'script-fu-show-image-structure-padding-opacity
  32.             (the-environment)))
  33.     (define script-fu-show-image-structure-padding-opacity 25))
  34. (if (not (symbol-bound? 'script-fu-show-image-structure-with-background?
  35.             (the-environment)))
  36.     (define script-fu-show-image-structure-with-background? TRUE))
  37. (if (not (symbol-bound? 'script-fu-show-image-structure-background-color
  38.             (the-environment)))
  39.     (define script-fu-show-image-structure-background-color '(0 0 0)))
  40.  
  41. (define (script-fu-show-image-structure img drawable new-image? space
  42.                     shear-length border apply-layer-mask?
  43.                     with-layer-name? with-pad? padding-color
  44.                     padding-opacity with-background? 
  45.                     background-color)
  46.   (if (eq? new-image? TRUE)
  47.       (begin (set! img (car (gimp-channel-ops-duplicate img)))
  48.          (gimp-display-new img)))
  49.   (let* ((layers (gimp-image-get-layers img))
  50.      (num-of-layers (car layers))
  51.      (old-width (car (gimp-image-width img)))
  52.      (old-height (car (gimp-image-height img)))
  53.      (new-width (+ (* 2 border) (+ old-width (* 2 shear-length))))
  54.      (new-height (+ (* 2 border) (+ old-height (* space (- num-of-layers 1)))))
  55.      (new-bg #f)
  56.      (old-foreground (car (gimp-palette-get-foreground)))
  57.      (old-background (car (gimp-palette-get-background)))
  58.      (layer-names '())
  59.      (layer #f)
  60.      (index 0))
  61.     (gimp-image-resize img new-width new-height 0 0)
  62.     (set! layers (cadr layers))
  63.     (gimp-selection-none img)
  64.     (while (< index num-of-layers) 
  65.       (set! layer (aref layers index))
  66.       (if (equal? "Background" (car (gimp-layer-get-name layer)))
  67.       (begin
  68.         (gimp-layer-add-alpha layer)
  69.         (gimp-layer-set-name layer "Original Background")))
  70.       (set! layer-names (cons (car (gimp-layer-get-name layer)) layer-names))
  71.       (if (not (= -1 (car (gimp-layer-mask layer))))
  72.       (gimp-image-remove-layer-mask img layer 
  73.                     (if (= TRUE apply-layer-mask?)
  74.                         APPLY
  75.                         DISCARD)))
  76.       (if (= TRUE with-pad?)
  77.       (begin
  78.         (gimp-selection-layer-alpha img layer)
  79.         (gimp-selection-invert img)
  80.         (gimp-layer-set-preserve-trans layer FALSE)
  81.         (gimp-palette-set-foreground padding-color)
  82.         (gimp-bucket-fill img layer FG-BUCKET-FILL NORMAL
  83.                   padding-opacity 0 0 0 0)
  84.         (gimp-selection-none img)))
  85.       
  86.       (gimp-layer-translate layer
  87.                 (+ border shear-length) (+ border (* space index)))
  88.       (gimp-shear img layer TRUE 0 (* (/ (car (gimp-drawable-height layer))
  89.                      old-height)
  90.                       (* -2 shear-length)))
  91.       (set! index (+ index 1)))
  92.     (set! new-bg (- num-of-layers 1))
  93.     (if (= TRUE with-background?)
  94.     (begin
  95.       (set! new-bg (car (gimp-layer-new img new-width new-height RGBA_IMAGE
  96.                         "New Background" 100 NORMAL)))
  97.       (gimp-image-add-layer img new-bg num-of-layers)
  98.       (gimp-palette-set-background background-color)
  99.       (gimp-edit-fill img new-bg)))
  100.     (gimp-image-set-active-layer img (aref layers 0))
  101.     (if (= TRUE with-layer-name?)
  102.     (let ((text-layer #f))
  103.       (gimp-palette-set-foreground '(255 255 255))
  104.       (set! index 0)
  105.       (set! layer-names (nreverse layer-names))
  106.       (while (< index num-of-layers)
  107.         (set! text-layer (car (gimp-text img -1 (/ border 2)
  108.                          (+ (* space index) old-height)
  109.                          (car layer-names)
  110.                          0 TRUE 14 PIXELS "*" "helvetica"
  111.                          "*" "*" "*" "*")))
  112.         (gimp-layer-set-mode text-layer NORMAL)
  113.         (set! index (+ index 1))
  114.         (set! layer-names (cdr layer-names)))))
  115.     (gimp-image-set-active-layer img new-bg)
  116.     (gimp-palette-set-background old-background)
  117.     (gimp-palette-set-foreground old-foreground)
  118.     (set! script-fu-show-image-structure-new-image? new-image?)
  119.     (set! script-fu-show-image-structure-space space)
  120.     (set! script-fu-show-image-structure-shear-length shear-length)
  121.     (set! script-fu-show-image-structure-border border)
  122.     (set! script-fu-show-image-structure-apply-layer-mask? apply-layer-mask?)
  123.     (set! script-fu-show-image-structure-with-layer-name? with-layer-name?)
  124.     (set! script-fu-show-image-structure-with-pad? with-pad?)
  125.     (set! script-fu-show-image-structure-padding-color padding-color)
  126.     (set! script-fu-show-image-structure-padding-opacity padding-opacity)
  127.     (set! script-fu-show-image-structure-with-background? with-background?)
  128.     (set! script-fu-show-image-structure-background-color background-color)
  129.     (gimp-displays-flush)))
  130.  
  131. (script-fu-register
  132.  "script-fu-show-image-structure"
  133.  "<Image>/Script-Fu/Utils/Show Image Structure"
  134.  "Show the layer structure of the image"
  135.  "Shuji Narazaki <narazaki@InetQ.or.jp>"
  136.  "Shuji Narazaki"
  137.  "1997"
  138.  "RGB*, GRAY*"
  139.  SF-IMAGE "image" 0
  140.  SF-DRAWABLE "Drawable (unused)" 0
  141.  SF-TOGGLE "Make new image" script-fu-show-image-structure-new-image?
  142.  SF-VALUE "Space between layers" (number->string script-fu-show-image-structure-space)
  143.  SF-VALUE "Shear length (> 0)" (number->string script-fu-show-image-structure-shear-length)
  144.  SF-VALUE "Outer Border (>= 0)" (number->string script-fu-show-image-structure-border)
  145.  SF-TOGGLE "Apply layer mask (or discard)" script-fu-show-image-structure-apply-layer-mask? 
  146.  SF-TOGGLE "Insert layer names" script-fu-show-image-structure-with-layer-name?
  147.  SF-TOGGLE "Padding for transparent regions" script-fu-show-image-structure-with-pad?
  148.  SF-COLOR "Pad Color" script-fu-show-image-structure-padding-color
  149.  SF-VALUE "Pad Opacity [0:100]" (number->string script-fu-show-image-structure-padding-opacity)
  150.  SF-TOGGLE "Make New Background" script-fu-show-image-structure-with-background?
  151.  SF-COLOR "Background Color" script-fu-show-image-structure-background-color
  152. )
  153.  
  154. ;;; image-structure.scm ends here
  155.